
# NOTE: some of the used Tk methods are undocumented. although not likely, they might
# be replaced one day. I will sign the as 'Fragile' .

package Sgdb::SourcePane ;
use Sgdb::Utils qw(:DEFAULT
                   menu_pop_common_View
                   menu_pop_common_Edit
                   menu_pop_NB_Raise
                   bind_search_mechanism
                   tracepoints_list
                   breakpoints_list
                   info_line_lookup
                   localconfig
                   window_geometry
                   get_a2l
                   ) ;

use warnings ;
use strict ;
use integer ;
use bytes ;

sub init {

    1 ;
}

sub new {
    my $self = shift or die "whoami" ;
    my $topf = shift or die "top frame needed" ;
    my $file = shift or return telme ("no file name" ) ;

    my $text = $topf->Scrolled ('ROText',
                                -takefocus => 1,
                                pref 'source-text' ,
                                ) ;

#    balloonset $text =><<DoC ;
#This pane is primarily used to view source files, 
#set tracepoints, dissasemble a particular function, 
#and to obtain basic information on symbols within 
#a scope or selected line \(address\). 
#Right-click to open a contex-sensitive action menu.
#Example: To debug a function, right-click the 
#beginning of any source line of the function, 
#select Tracepoins, then choose among 
#Function Coverage, Function Debug, 
#Function Debug Locals. Sgdb will 
#automatically set tracepoints, including some 
#standard actions, and display them in the right 
#pane. You can modify them by using the Actions pane. 
#Tip: When viewing disassembled sources, you can 
#get help on assembly commands by right-clicking 
#a command then selecting assembly info 
#\(explanation will be displayed in the 
#bottom of the screen\). 
#You can also use common edit and 
#search features available upon a right-click.
#DoC

    pref_reconfigure  'source-text' => $text  ;

    if    ($file =~ /\.[hc].?.?$/i and
           require Sgdb::SourceSyntaxC ) {

        $text -> insert( 'end',
                         @ { Sgdb::SourceSyntaxC::parse( $file ) }
                         ) ;

    }
    elsif ($file =~ /\.(?:s|ppcs|a|asm|S|src)$/ and
           require Sgdb::SourceSyntaxAsm ) {

        $text -> insert ( 'end',
                          @ { Sgdb::SourceSyntaxAsm::parse( $file ) }
                          ) ;
    }
    elsif ($file =~ /\.j\w*$/ and
           require Sgdb::SourceSyntaxJ ) {

        $text -> insert ( 'end',
                          @ { Sgdb::SourceSyntaxJ::parse( $file ) }
                          ) ;

    }
    else {

        if (open FILE, $file) {
            $text->insert('end',
                          join '', <FILE>
                          ) ;
            close FILE ;
        }
        else {
            $text->insert('end',
                          "\n\ncan't open the file $file: $!\n"
                          ) ;
        }
    }

    nice_source_tags_for( $text ) ;
    mark_lines( $text ) ;              #  add lines num TODO if preference ..
    add_header( $text, $file) ;
    highlight_pathes($text, $file ) if pref "highlight-patches-in-source" ;
    nice_popup_menu_for( $text, 1 ) ;
    bind_search_mechanism( $text ) ;
    $text -> bind ('<Control-1>', [\&info_line_lookup, 'face-code' ]) ;
    $text ;
}

sub nice_popup_menu_for {       # runs once for every new source

    my $t = shift ;
    my $m = $t->menu() ;
    my $nb = shift ;

    my $sm_View = $m -> Menu (-tearoff => 0,
                              pref( 'pop-menu' )
                              ) ;

    my $view_offset = $t->tagCget('asm-offset', '-elide') ;
    my $view_asm    = $t->tagCget('asm-comm'  , '-elide') ;

    menu_pop_common_View( $t, $sm_View ) ;

    my $sm_Edit = $m -> Menu (-tearoff => 0,
                              pref( 'pop-menu')
                              ) ;

    menu_pop_common_Edit( $t, $sm_Edit ) ;

    $m->configure(-postcommand => [\&popup_menu_for_source_pane,
                                   $m, $t, $sm_View, $sm_Edit, \$view_offset, \$view_asm, $nb],
                  pref( 'pop-menu' )
                  ) ;
}

sub popup_menu_for_source_pane {
                                # runs every right click (on source)

    my ($m, $t, $sm_View, $sm_Edit, $view_offset, $view_asm, $nb) = @_ ;
    my ($w, $addr, $sm) = '';

    $m -> delete(0, 'end') ;

    my $current = $t -> index ( 'current' ) ;

    my @tagnames      =   $t->tagNames( $current ) ;

    my ($file, $line) = ( $t->get("1.1 linestart", "1.1 lineend"),
                          get_source_line ( $t, $current, 'b4')
                          ) ;

    my @pref_menu_pop = pref 'pop-menu' ;

                                # lookup keyword
    if    ( grep {$_ eq 'sel'} @tagnames and
            $t -> compare ("sel.first + 2 lines", '>', "sel.last") ) {
                                # selection

        $w = $t->get( 'sel.first', 'sel.last') ;
        chomp $w ;              # just in case user selected too much
    }
    elsif ( grep {$_ eq 'face-code'} @tagnames )  {
                                # code tag: meaningful commands
        # $w = $t->get ("$current wordstart", "$current wordend") ;
        # chomp $w ;              # just in case user selected too much
        $w = text_current_word $t, $current ;
    }
    elsif ( grep {$_ eq 'asm-addr'} @tagnames ) {

        $addr = '*' . text_current_word $t, $current;
          # $t -> get ("$current wordstart", "$current wordend" ) ;
    }
    elsif ( grep {$_ eq 'linenumber'} @tagnames ) {

        $addr = "$file:$line" ;
    }

    if (grep {$_ eq 'annotate'} @tagnames ) {
        my $anno = $t -> get ("$current linestart", "$current lineend");
        if ($anno =~ /^\s*\d+\:[^\:]+?[\(\[](\w+)/ ) {
            my $uname = $1 ;
            menu_fill $m, '',
              [ "finger $uname", sub {
                    my $finger = localconfig 'finger' ;
                    telthem ( qx/$finger -m $uname/ || "$uname is un-finger-able" );
                }], '---' ;
        }
    }

    if ( $addr ) {

        my ($tpnum, $bpnum ) ;
        my @b_tagnames =  $t -> tagNames( "$current linestart" ) ;

        $tpnum = get_breackpoint_num ( $addr, 'trace' ) if grep /tracepoint$/, @b_tagnames ;
        $bpnum = get_breackpoint_num ( $addr, 'break' ) if grep /breakpoint$/, @b_tagnames ;

        my ($rng_start, $rng_end) ;

        if ( grep {$_ eq 'sel'} @tagnames ) {
            $rng_start = $file . ':' . get_source_line ( $t, 'sel.first', 'before' ) ;
            $rng_end   = $file . ':' . get_source_line ( $t, 'sel.last' , 'after'  ) ;
        }

        menu_fill ( $m, 'pop-menu',

                    'Breakpoints',
                    ( $bpnum ?
                      ( [ "commands $bpnum", [ \&gdb_exec_lock, "commands $bpnum" ]],
                        '-',
                        [ "disable  $bpnum", [\&gdb_exec_lock, "disable $bpnum"]],
                        [ "delete   $bpnum", [\&gdb_exec_lock, "delete $bpnum" ]],
                      ) :
                      ( [ "break $addr", [\&gdb_exec_lock, "break $addr"]],
                        [ "tbreak $addr", [\&gdb_exec_lock, "tbreak $addr"]],
                      )
                    ),

                    'Tracepoint',
                    [ "trace $addr", [\&gdb_exec_lock, "trace $addr"], ],
                    '-',
                    [ "Function Coverage", [\&hook_run_lock, 'trace-function-coverage',       $addr], ],
                    [ "Function Debug",    [\&hook_run_lock, 'trace-function-debug',          $addr], ],
                    [ "Function Debug Locals", [\&hook_run_lock, 'trace-function-debug-locals',   $addr],],
                    ( iff  $rng_start && $rng_end,
                      '-',
                      [ 'Range Coverage', [\&hook_run_lock, 'trace-function-coverage',     $rng_start, $rng_end] ],
                      [ 'Range Debug', [\&hook_run_lock, 'trace-function-debug',        $rng_start, $rng_end] ],
                      [ 'Range Debug Locals', [\&hook_run_lock, 'trace-function-debug-locals', $rng_start, $rng_end] ],
                    ),
                    ( iff  $tpnum || substr ( $addr, 0, 1 ) eq '*',
                      '-'
                    ),
                    ( iff substr ( $addr, 0, 1 ) eq '*',
                      [ "tfind pc " . substr ($addr, 1) , [\&gdb_exec_lock, "tfind pc " . substr ($addr, 1)] ],
                      [ "tfind pc - " . substr ($addr, 1) , [\&gdb_exec_lock, "tfind pc -" . substr ($addr, 1)] ],
                    ),
                    ( $tpnum ?
                      ( [ "tfind tp $tpnum", [\&gdb_exec_lock, "tfind tracepoint $tpnum"] ],
                        [ "tfind tp - $tpnum", [\&gdb_exec_lock, "tfind tracepoint -$tpnum"]],
                        '-',
                        [ "actions $tpnum", [\&hook_run_lock, 'set-tracepoint-action', $tpnum]],
                        [ "tstatus $tpnum", [\&gdb_exec_lock, " tstatus $tpnum"]],
                        '-',
                        [ "disable $tpnum", [\&gdb_exec_lock, "disable tracepoint $tpnum"]],
                        [ "delete  $tpnum", [\&gdb_exec_lock, "delete tracepoint $tpnum"]],
                        '-',
                        [ "tp Cut  $tpnum", [\&hook_run_lock, 'tracepoints-clipboard', 'cut' , $tpnum ]],
                        [ "tp Copy $tpnum", [\&hook_run_lock, 'tracepoints-clipboard', 'copy', $tpnum ]],
                        [ "tp Paste to $tpnum", [\&hook_run_lock, 'tracepoints-clipboard', 'paste',$tpnum ]],
                      ) :
                      ('-')
                    ),
                    [ "tp create & Paste", [\&hook_run_lock, 'tracepoints-clipboard', 'new', $addr]],

                    '---',
                  ) ;
    }

    if ($w =~ /\w/ and $w !~ /\n/ ) { # legal key word && single line key

        my $tab = sub {
            my ($a, $b) = @_ ;
            join ' ' x (9 - length $a), $a, $b
        } ;
        menu_fill ($m, 'pop-menu',
                   'Query',
                   ( map { (ref $_ ?
                            [$tab->($_->[0], $w), [\&hook_run, $_->[1], $w]] :
                            $_ eq '-' ?
                            $_ :
                            [$tab->($_, $w), [\&gdb_exec_lock, "$_ $w"] ] ) }
                     'ptype'   ,
                     'whatis ' ,
                     '-'       ,
                     'p'       ,
                     'p*'      ,
                     'p/x'     ,
                     'p/x *'   ,
                     'p/x &'   ,
                     'psl 0'   ,
                     '-'       ,
                     ["Watch.. " , 'add-watch'    ],
                     ["Symbol.. ", 'symbol-lookup'],
                     ["Usage.. " , 'usage-lookup' ],
                     ['ETags.. ' , 'etags-lookup' ],
                   ), '---',
                   );
    }

    # Asm dictionary
    if (grep {$_ eq 'asm-comm'} @tagnames and
        $t -> tagPrevrange( 'asm-comm', $current) ) {
                                # asm commands. want dictionary?

        $addr = $t -> get ("$current linestart", "$current wordstart" ) ;
        $addr =~ s/^(0x[a-f\d]+).*/$1/;

        my $cmd = $t->get( $t->tagPrevrange( 'asm-comm', $current)) ;
        my $num = $t->get( "$current wordstart -1 c", "$current wordend" ) ;
        $num =~ s/^[^\-]// ;
        my $numt = ( $num =~ /^(-?)(0x[a-f\d]+)$/ ?
                     (sprintf "dec: %d", $num = ( $1 ? 0 - hex( $2 ) : 0 + hex( $2 ) ) ) :
                     $num =~ /^-?\d+$/ ?
                     (sprintf "hex: 0x%x", $num ) :
                     undef
                   ) ;

        if ($cmd =~ /^\s*(\S+)/ ) {
            menu_fill( $m, '',
                       [ "asm dictionary: $1", [\&lookup_asm_dictionary, $1]],
                       [ "asm binary: $addr", [\&show_asm_binary, $addr]],
                       (iff $numt,
                        [$numt , sub {telthem sprintf "%d is hex 0x%x is binary 00%b", $num, $num, $num}],
                       ),
                       '---',
                     )
        }
    }

    menu_fill
      ( $m, 'pop-menu',
        Disassemble =>
        iff ((grep { $_ eq 'sel' } @tagnames and
              $t -> compare ("sel.first + 1 l linestart", '<', "sel.last")),
             [ 'Selected Range', [\&runlocked, \&disassemble_range, $t]]
            ) ,
        [ 'This Function', [\&runlocked, \&disassemble_range, $t, $file, $line]],
        [ 'Whole File', [\&runlocked, \&disassemble_range, $t, $file, 0, 'whole']],
        [ 'Clear All', [\&runlocked, \&forget_disassemble, $t]],
        '-',
        [['checkbutton',
          -label => 'Hide Offsets',
          -variable => $view_offset,
          -command => sub {
              $t -> tagConfigure('asm-offset',
                                 -elide => $$view_offset
                                )
                unless $$view_asm ;
          }
         ]],
        [['checkbutton',
          -label => 'Hide Assembler',
          -variable => $view_asm,
          -command => sub {
              $t -> tagConfigure('asm-comm',
                                 -elide => $$view_asm
                                ) ;
              $t -> tagConfigure('asm-addr',
                                 -elide => $$view_asm
                                ) ;
              $t -> tagConfigure('asm-offset',
                                 -elide => $$view_asm
                                )
                unless $$view_offset ;
          }
         ]],

        Info =>
        ( $w =~ /^0x[\da-f]+$/ ?
          (
           [ "info line   *$w", [\&gdb_exec_lock, "info line *$w"]] ,
           '-',
          ) :
          $w =~ /^\w+$/ ?
          (
           [ "info line    $w", [\&gdb_exec_lock, "info line $w"]],
           [ "info address $w", [\&gdb_exec_lock, "info address $w"]] ,
           '-',
          ) :
          $w  ?
          (
           [ "info line  *($w)", [\&gdb_exec_lock, "info address *($w)"]],
           '-',
          ) :
          ()
        ),
        [ "info scope    $file:$line", [\&gdb_exec_lock, "info scope $file:$line"]],
        [ "info line     $file:$line", [\&gdb_exec_lock, "info line $file:$line"]] ,
        '--',
        Edit => $sm_Edit ,
        View => $sm_View ,

        'Annotate & More' =>
        [ 'Annotate This', [\&runlocked, \&annotate_this, $t, $file]],
        [ 'Annotate Window', [\&runlocked, \&annotate_window, $t, $file]],
        [ 'Annotate Hide', [\&annotate_hide, $t] ,
          -state   => ($t -> tagRanges('annotate')) ? 'normal' : 'disabled',
        ],
        '-',
        [ 'Highlight Patches', [\&highlight_pathes, $t ],
          -state   => (gdb_cached('syren-v') || '') =~ /\"\d+ \d+ \d+/ ? 'normal' : 'disabled',
        ],
        '-',
        [ 'Save As ..', [\&save_source_pane,$t]],
        [ 'New Window', [\&open_new_window,$t, $file]],
        '--',
        ( iff $nb,
          '-',
          'Raise Page', menu_pop_NB_Raise( $m, $t),
          '--',
          ['close source', [\&hook_run, 'close-current-source-pane' ]],
        ),
      );

   }

sub open_new_window {
    my ($old, $file ) = @_  ;

    my $nw = $mainwindow -> Toplevel () ; # -width => 600, -height => 40  0) ;
    $nw -> title( $file ) ;
    window_geometry sourcwin => $nw;
    $nw -> iconimage ( pref_image ( 'sgdbtk' ) ) ;

    my $t  = $nw -> Scrolled( 'ROText', pref 'source-text' ) ;

    pref_reconfigure  'source-text' => $t ;

    # copy text
    $t -> insert ( 'end' , $old->get( '1.0' => 'end') ) ;

    # copy tags
    foreach my $tag ($old -> tagNames() ) {
        my @ranges = $old -> tagRanges( $tag ) ;
        while ( @ranges ) {
            $t -> tagAdd ( $tag , splice @ranges, 0, 16) ;
        }
    }

    foreach my $mark     (        $old -> markNames  (     )) {
        $t -> markSet    ( $mark, $old -> index      ($mark)) ;
        $t -> markGravity( $mark, $old -> markGravity($mark)) ;
    }

    nice_source_tags_for ( $t ) ;
    nice_popup_menu_for  ( $t ) ;
    bind_search_mechanism( $t ) ;
    $t -> yviewMoveto( ($old -> yview )[0] || 0 ) ;

    $t -> pack ( -fill => 'both' ,
                 -expand => 1 ,
               ) ;
}

sub save_source_pane {
    my $t = shift or return ;
    my $pref = 'last-source-save-filename' ;
    my $f = find_file ( 1,
                        'Save Source Pane Context as ..',
                        pref ( $pref ) || '' ,
                      ) or return ;

    open  FILE, ">$f" or return telthemloud "cannot open file '$f': $!" ; 
    print FILE $t -> get ( '1.0' => 'end' ) ; 
    close FILE ;
    pref_set $pref, $f ;
    $f ;
}

sub add_header {

    no integer ;

    my ($t, $f) = @_ ;
    if (-e $f ) {

        $t->insert('L1',
                   join ('',
                         $f =~ /([^\/]*)$/ ,
                         "\nFull Name: $f\nModified " ,
                         int (-M $f) ,
                         " days ago\n\n") => 'fileheader'
                   ) ;

        my $file = gdb_cached( 'file' ) ;

        if ( index ( $f, 'sgdb_scratch' ) < 0 and $file and -M $f < -M $file ) {

            $t->insert('L1',
                       "*** Source Was Modified Since Compilation ***\n\n" =>
                       'fileheader-warning'

                       ) ;

            telthemloud "$f WAS MODIFIED SINCE COMPILATION!!" ;
        }
    }
    else {
        $t -> insert( 'L1',
                      "Full Name: $f NOT EXISTS!\n" => 'fileheader-warning'
                      ) ;
    }
}

sub highlight_pathes {
    my ($t, $f) = @_ ;
    ($f) = $t -> get ("2.0", "2.0 lineend") =~ /(\/.*)$/ unless $f;
    return unless $f and $f =~ /\.sgdb_scratch/ ;
    return unless -e $f and -e "$f.cmr" ;
    my $diff = localconfig 'diff'    or return telthemloud "no diff program" ;
    open F, "$diff -u0 $f.cmr $f |"  or return telthemloud "$diff: $!" ;
    while (<F>) {
        /\@\@[\s\-\,\d]*\+(\d+)(?:,(\d+))?\s*\@\@/ or next ;
        my ($a, $z) = ($1, $1 + ($2 || 1)) ;
        eval { tagAdd $t 'highlight-patches', "L$a", "L$z" } ;
        telme $@ if $@ ;
    }
    close F ;
}

sub annotate_hide {
    hide Sgdb::Cntr::Annotate (@_)
}

sub annotate_this {

    return telthemloud "can't use Sgdb::Cntr::Annotation: $@"
      unless require Sgdb::Cntr::Annotate ;

    my ($t, $f) = @_ ;
    my ($full) = $t -> get ("2.0", "2.0 lineend") =~ /(\/.*)$/ ;
    this Sgdb::Cntr::Annotate ($t, $f, $full ) ;
}

sub annotate_window {

    return telthemloud "can't use Sgdb::Cntr::Annotation: $@"
      unless require Sgdb::Cntr::Annotate ;

    my ($t, $f) = @_ ;

    &highlight_pathes unless $t -> tagRanges('highlight-patches');

    unless (istkwidget $t->{__Annotation__}) {
        my $top = $mainwindow -> Toplevel() ;
        $top -> title ("Annotate $f") ;
        window_geometry annotate => $top ;
        $top -> iconimage ( pref_image ( 'sgdbtk' ) ) ;
        my ($full) = $t -> get ("2.0", "2.0 lineend") =~ /(\/.*)$/ ;
        $t->{__Annotation__} = new Sgdb::Cntr::Annotate ($top, $t, $f, $full) ;
    }
    $t -> {__Annotation__} -> toplevel() -> raise( $t -> toplevel() ) ;
    $t -> {__Annotation__} -> focus() ;
    $t -> {__Annotation__} -> yviewMoveto( ($t -> yview)[0] || 0) ;
}

sub mark_lines {
    my $t = shift ;
    my ($l) = $t->index('end') =~ /(\d+)\./ ;
    while (-- $l) {
        $t->insert ("$l.0", (' ' x (4 - length($l))) . "$l:" , 'linenumber') ;
        $t->markSet("L$l", "$l.0");
    }
    $t->markSet("Lstart", '1.0') ;
    $t->markGravity("Lstart", 'left') ;
    $t->markSet("Lend", 'end');
    $t->markGravity("Lend", 'right'); 
}

sub nice_source_tags_for {

    my $t = shift ;
    pref_tags $t, 'source', qw/fileheader fileheader-warning highlight-patches linenumber
                               face-comments face-instructs face-quotations face-keywords face-knowntypes
                               asm-osrc asm-ocomm asm-addr asm-offset asm-comm
                               cur-line cur-address
                               loc-tstatus-mis loc-tstatus-hit
                               branchp-mis branchp-con branchp-hit
                               loc-dis-tracepoint loc-tracepoint loc-dis-breakpoint loc-breakpoint/ ;

    $t -> tagBind ( 'asm-osrc', '<1>', [\&handle_clicked_asm_osrc, $t]) ;
    $t -> tagBind ( 'asm-osrc', '<Enter>', [$t, 'configure', -cursor => 'arrow'] ) ;
    $t -> tagBind ( 'asm-osrc', '<Leave>', [$t, 'configure', -cursor => 'xterm'] ) ;
    $t
}

sub forget_disassemble {

    my $t = shift or return ;

    my @ranges = $t->tagRanges('asm-addr') ;
    my $l ;
    while (@ranges) {
        pop @ranges ;
        $l = pop @ranges ;
        $t->delete( $l, "$l lineend +1 chars") ;
    }

    hook_run 'refresh-breakpoints' ;
}

sub disassemble_range {

    my ( $t, $file, $line, $type, @params )  = @_ ;
    # telme $file, $line, $type ;
    my $disparam ;
    my $pointofview = $t -> markNext ( 'current' ) || 'end' ;
    $type ||= '' ;

    if ( $type eq 'whole' ) {

        $disparam = gdb_exec_quiet "info range $file" ;

        unless ($disparam and $disparam =~ /^\s*0x[\da-f]+\s+0x[\da-f]+/i) {

            telme 'no info rage, trying the old way' ;
            my ($addr1) =
              gdb_exec_quiet( "info line $file:1" ) =~ /(0x[\da-f]+)/
                or return ;

            my $end = get_source_line( $t, 'end', 'before' ) ;

            my ($addr2) =
              gdb_exec_quiet( "info line $file:$end" )  =~ /(0x[\da-f]+)/ ;

            while ( ! $addr2 and $end ) {
                $end -- ;
                ( $addr2 ) = gdb_exec_quiet( "info line $file:$end" )  =~ /.*(0x[\da-f]+)/ ;
            }
            $addr2 or return ;

            $disparam = hex($addr2) > hex($addr1) ? "$addr1 , $addr2" : "$addr2 , $addr1" ;
        }
    }
    elsif ( $type eq 'branchp' or
            $type eq 'BRANCHP') {

        if ( $line ) {
            ($disparam) = gdb_exec_quiet ( "info line $file:$line" ) =~ /\<([\w\.]+).*\>/;
        } else {
            $disparam = gdb_exec_quiet "info range $file" ;
        }
        if ($type eq 'branchp') {
            die "disassemble_range: branchp called with bad params\n" unless
              'ARRAY'  eq ref $params[0] and
                'Regexp' eq ref $params[1] ;
            $params[2] ||= 0 ;
            $params[3]   = 0 ;
       }
        if ($type eq 'BRANCHP') {
            die "disassemble_range: branchp called with bad params\n" unless
            'ARRAY'  eq ref $params[0] and
              'Regexp' eq ref $params[1] and
              defined($params[2]);
       }
    }
    elsif ($file and $line ) {

        ($disparam) =
            gdb_exec_quiet ( "info line $file:$line" ) =~
                /\<([\w\.]+).*\>/
                    or return ;
    }
    elsif ( $t->tagRanges('sel') ) {

        $file ||= $t->get("1.1 linestart", "1.1 lineend") ;

        my $start = get_source_line($t, "sel.first", 'before') or return ;
        my $end   = get_source_line($t, "sel.last" , 'after' ) or return ;

        # Line 569 of "../lru.c" starts at address 0x52638c <lock_lru> and ends at 0x5263c4 <lock_lru+56>.

        my ($addr1) =
            gdb_exec_quiet( "info line $file:$start" ) =~ /(0x[\da-f]+)/
                or return ;

        my ($addr2) =
            gdb_exec_quiet( "info line $file:$end" )  =~ /(0x[\da-f]+)/ ;

        while ( ! $addr2 and $end > $start ) {
            $end -- ;
            ( $addr2 ) = gdb_exec_quiet( "info line $file:$end" )  =~ /(0x[\da-f]+)/ ;
        }
        $addr2 or return ;

        $disparam = "$addr1 , $addr2" ;
    }
    else {

        $file ||= $t->get("1.1 linestart", "1.1 lineend") ;

        $line = get_source_line($t, "current", 'after' ) or return ;

        ( $disparam ) =
            gdb_exec_quiet ( "info line $file:$line" ) =~ /\<([\w\.]+).*\>/
                or return ;
    }

    # got disparams, init the loop's params:
    # my @ranges ;
    # {   # fill ranges
    #     my  $range = gdb_exec_quiet( "mai info lines $disparam" ) ;
    #     if (!$range or
    #         $range =~ /^\s*Undefined info command/ ) { # old m68?
    #         $range = gdb_exec_quiet( "info orientation $disparam" ) ;
    #     }
    # 
    #     use File::Basename 'basename' ;
    #     my $filebasename = basename $file ;
    #     my %bname ;
    #     my $fname = sub { my $f = shift ; $f and ($bname{$f} ||= basename $f) ne $filebasename ? $f : '' } ;
    #     for (split /^/, $range ) {
    #         # 0x38e5a07:4591:services/gmm/cache_allocation.c
    #         # 0x38e58cf:103:inc/ia32/sk_inline_asm.h
    #         /(0x[\da-f]+):(\d+)(?:\:(\S+))?/i or next ;
    #         next unless $2 ;
    #         push @ranges, [hex($1), $2 +1 , $fname->($3)]
    #     }
    # 
    #     unless (@ranges) {
    #         # no data ...
    #         return if $type eq 'auto' ;
    #         return gdb_exec ( "disassemble $disparam" ) ;
    #     }
    # 
    #     @ranges = sort {$a->[0] <=> $b->[0]} @ranges ;
    # }
    my $assm = gdb_exec_quiet( "disassemble $disparam " );

    my $addr2l = get_a2l() ;

    my $a2l = $addr2l->asm_lines($assm);
    return gdb_exec ( "disassemble $disparam" ) unless %$a2l;

    $type = '' unless $type eq 'branchp' or $type eq 'BRANCHP' ;
    my ($cur_line, $next_range, $cur_file, %cache_cur_asm) = (0,0, '') ;

    use File::Basename 'basename' ;
    my $thisfile = basename $t->get("1.1 linestart", "1.1 lineend");
    no warnings 'portable';
    foreach (split /^/, $assm) {

        my ($add, $offset, $comm) = /(0x[\da-f]+)(.*?:)(.*\w.*)/i or next ;
        $add = hex $add ;
        my $addr = sprintf '0x%08x', $add ; # my format

        {
            my @a = split ':', ($a2l->{$add} || '') ;
            if (@a > 2) {
                for (my $i = 0; $i < @a ; $i +=1 ) {
                    if ($a[$i] eq $thisfile) {
                        @a[0, 1] = @a[$i, $i+1] if $i ;
                        last ;
                    }
                }
            }
            if (@a > 1) {
                $cur_file = $a[0] ne $thisfile ? "  <$a[0]:$a[1]>\n" : '';
                $cur_line = $a[1];
            }
            elsif (not $cur_file) {
                telthem ("unknown asm: $_");
                # return gdb_exec ( "disassemble $disparam" );
            }
            $cur_line ||= 1;
        }
        # unless ($add < $next_range) {
        #     my $r = shift @ranges ;
        #     $next_range = $ranges[0][0] || 0xffff_ffff ;
        #     if ($r->[2]) {
        #         $cur_file = "  <$r->[2]:$r->[1]>\n" ;
        #     }
        #     else {
        #         $cur_file = '' ;
        #         $cur_line = $r->[1] || $cur_line ;
        #     }
        # }

        if (not $type) {

            my $f = eval { $cache_cur_asm{$cur_line} ||= $t -> get ( map {"L$_"} $cur_line - 1, $cur_line ) } || '' ;
            # algo: assuming the assmler is ordered and unique, we should only check
            # the status before this function was called

            $t -> insert ( "L$cur_line",
                           $addr,     'asm-addr',
                           $offset,   'asm-offset',
                           ($cur_file ?
                            ( $comm,    'asm-ocomm', $cur_file, 'asm-osrc') :
                            ("$comm\n", 'asm-comm' , )
                           ),
                         ) if 0 > index $f, "\n$addr" ;
            next ;
        }

        elsif ($type eq 'branchp') {
            # special mode:
            # 1. no prev disassemble
            # 2. flip flop highlight branches
            # 3. @params = array, regexp, flipflop, index

            # my $add = hex $addr ;

            my( $ref, $reg, $inx, $flp ) = @params ;

            $inx ++  while $ref -> [$inx] <  $add and $inx < $#{$ref} ;

            $flp = 2 if    $ref -> [$inx] == $add ;

            # insert
            $t->insert( "L$cur_line",
                        $addr,  ['asm-addr', qw(branchp-mis branchp-con branchp-hit)[$flp] ],
                        $offset, 'asm-offset',
                        "$comm\n", 'asm-comm',
                      );

            $params[2] = $inx ;
            $params[3] = (($flp and $comm !~ $reg)
                          ? 1
                          : 0 ) ;

            next ;
        }

        elsif ($type eq 'BRANCHP') {
            my $hit = 0;
            my( $ref, $reg, $i ) = @params;
            for (; $i<$#{$ref}; $i++) {
                my ($sa,$l) = @{$ref->[$i]};
                if ($add < $sa) {
                    $hit = 0;
                    last;
                } elsif ($add < $sa+$l) {
                    $hit = 1;
                    last;
                }
            }
            $t->insert( "L$cur_line",
                        $addr,  ['asm-addr', qw(branchp-mis branchp-hit)[$hit]],
                        $offset, 'asm-offset',
                        "$comm\n", 'asm-comm',
                      );
            $params[2] = $i;
            next;
        }
    }
    $t -> see ( $pointofview ) ;
    hook_run 'refresh-breakpoints' ;
}

sub handle_clicked_asm_osrc {
    my $t = shift ;
    my $c = $t -> index ('current');
    my $l = $t -> get ("$c linestart", "$c lineend") ;
    my ($file, $line) = $l =~ /\<(\S+):(\d+)>\s*$/ or return ;
    gdb_exec "i line $file:$line" ;
}

sub get_source_line {

    my ($t, $addr, $direction) = @_ ;
    $direction = $direction && lc( $direction ) !~ /after|next/ ;
    my $mark ;
    my $loopl = 50 ;

    if ($direction) {

        $mark = $t->markPrevious( $addr ) || 'L1' ;
        while (--$loopl) {

            $mark =~ /L(\d+)/ and return $1 ;
            $mark =~ /Lstart/ and return 1 ;
            $mark = $t->markPrevious("$mark -1 chars") ;
        }
    }
    else {

        $mark = $t->markNext( $addr ) ;
        while (--$loopl) {

            $mark =~ /L(\d+)/ and return $1 ;
            $mark =~ /Lend/   and return get_source_line($t, 'end', 'before') ;
            $mark = $t->markNext("$mark +1 chars") ;
        }
    }
    telme ("sanity: last mark = $mark") ;
}

sub show_asm_binary {
    my $addr = shift;

    my ($insn,$size) = split(/\n/,gdb_exec_quiet("x/2i $addr"));
    chomp $insn;
    $insn =~ s/(.*?:)\s*(\S.+)/$2/;
    chomp $size;
    $size =~ s/\s*(\S+)\s+.*$/$1/;
    $size = (hex($size) - hex($addr));
    my $bits = gdb_exec_quiet("x/${size}xb $addr");
    chomp $bits;
    $bits =~ s/(.*?:)\s*(.+)$/$2/;
    $bits =~ s/\s0x//g;
    telthem "$addr: $bits = $insn";
}

{
    my %asm_dictionary ;

    sub lookup_asm_dictionary {

        initialize_asm_dictionary() unless exists $asm_dictionary{ 'asm-dictionary-file' } ;
        my $key = shift() ;
        my $val = $asm_dictionary{ $key } ;
        telthem ( $val ?
                  "'$key' is $val" :
                  "'$key' is unknown" ) ;
    }

    sub initialize_asm_dictionary {

        # my $file = gdb_cached( 'asm-dictionary' ) ;
        # 
        # %asm_dictionary = ('asm-dictionary-filename' => $file ) ;
        # 
        # hook_add ('new-symbol-file-name', [sub {
        #     %asm_dictionary = () unless
        #         gdb_cached( 'asm-dictionary' ) and
        #             gdb_cached( 'asm-dictionary' ) eq
        #                 $asm_dictionary{ 'asm-dictionary-file-name' } }]) ;
        my $file = localconfig "asm-dictionary";

        open FILE, $file or return telthem("can't open $file: $!") ;

        my ($doc, @commands ) = '' ;
        while (<FILE>) {        # a little dirty, it was copied from tcl..
            if (s/^\%//) {
                chomp $doc ;
                @asm_dictionary{ @commands } = ($doc) x @commands ;
                @commands = split ' ', lc ;
                $doc = '' ;
            }
            else {
                $doc .= $_ ;
            }
        }
        close FILE ;
    }

}

sub highlight_assembly_line {

    my ($t, $pc, $l, $f)  = @_ ;

    $t -> tagRemove( 'cur-address', '1.0', 'end') if $t -> tagRanges( 'cur-address' ) ;

    my $start = eval {  $l and $t -> index ("L$l") } || '3.0' ;

    $pc =~ s/^0x/0x0*/ ;
    my  $loc = $t -> search (-regexp => -hidden => "^$pc", $start) ;

    if( !$loc and $l and pref 'disassemble-while-stepping' ) {

        disassemble_range( $t, $f, $l, 'auto') ;

        $loc = $t -> search (-regexp => -hidden => "^$pc", $start ) ;
    }

    if ( $loc ) {

        $t -> see ( $loc ) ;
        # Perlon: most cases this operation will do nothing
        $t -> tagAdd ('cur-address', "$loc", "$loc wordend") ;
    }
}

sub get_breackpoint_num {

    my ($addr, $type, $line ) = @_ ;

    if     ( $type eq 'trace' ) {

        foreach $line (reverse tracepoints_list ( $addr )) {

            $line =~ /^(\d+)\s+[yn]/ or next ;
            return $1 ;
        }
        telme "can't find tracepoint in $addr" ;
    }
    elsif ( $type eq 'break' ) {

        foreach $line (reverse breakpoints_list ( $addr )) {

            $line =~ /^(\d+)\s+breakpoint/ or next ;
            return $1 ;
        }
        telme "can't find breakpoint in $addr" ;
    }
    else {

        telme "bad type: $type" ;
    }
    '' ;
    # Note: in gdb there is not breakpoint and traceppoint 0, therefore this
    # function returns false for unknown number.
}

init() ;
